home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
MacHack 1994
/
MacHack 1994.toast
/
MacHack™94
/
Talks & Papers
/
Timothy Knox
/
Help
/
Help Files
/
ATMS
/
• v 1.5 (atms)
next >
Wrap
Text File
|
1994-06-24
|
22KB
|
500 lines
{differences avec v1.5: Toutes les feuilles d'échec}
(warn ƒ
(define (just l)
(warn () (raz))
(let [(ls&ns (creer…ls&ns l 0))]
(define *ts* (apply cell (0 ls&ns)))
(define *ns* (1 ls&ns))
(just…*tc* l)))
(define (just…*tc* l)
(let [(lc&nsmax (creer…lc&nsmax l 0))]
(define *tc* (apply cell (0 lc&nsmax)))
(define *nc* (1- (blength *tc*)))
(define *nsmax* (1 lc&nsmax))
(just…*tc/s&*tc/nxx* l)))
(define (just…*tc/s&*tc/nxx* l)
(letrec [((init…tc/s i t)
(cond (>? i *ns*) t
(begin (cell=! t i (cell (makebitarray *nc*)(makebitarray *nc*)))
(init…tc/s (1+ i) t))))
((init…tc/nxx i t)
(cond (>? i *nsmax*) t
(begin (cell=! t i (makebitarray *nc*))
(init…tc/nxx (1+ i) t))))
(tc/s&tc/nxx (creer…tc/s&tc/nxx 0 (init…tc/s 0 (makecell (1+ *ns*) 0))
(init…tc/nxx 0 (makecell (+ *nsmax* 1) 0))
(init…tc/nxx 0 (makecell (+ *nsmax* 1) 0))))
(tc…s-> (bitand (1 (1 tc/s&tc/nxx)) (0 (2 tc/s&tc/nxx))))
(tc…->s (bitand (0 (1 tc/s&tc/nxx)) (1 (2 tc/s&tc/nxx))))]
(define *tc/s* (0 tc/s&tc/nxx))
(define *msk* (bitnot! (makebitarray *nc*)))
(define *a->b* (avancer…pg!ts (trouver…ts! pd (bitfind tc…->s) tc…->s)
(1 tc/s&tc/nxx) (2 tc/s&tc/nxx) *msk*
(avancer…pd!ts (trouver…ts! pg (bitfind tc…s->) tc…s->)
(1 tc/s&tc/nxx) (2 tc/s&tc/nxx) *msk*
(cell (makebitarray *ns*) (makebitarray *ns*)))))
(accede *a->b*)
(define *tc/nsg* (1 tc/s&tc/nxx))
(define *tc/nsd* (2 tc/s&tc/nxx))))
(define (creer…ls&ns lc n)
(cond (null? lc) (cell () n)
(letrec [((loop ls n l&n)
(cond (null? ls) (cell n l&n)
(let [(s (intern 'dk (0 ls)))]
(cond (warn () (error? (binding=? s ())))
(begin (binding=! s () n)
(let [(etc (loop (-1 ls) (1+ n) l&n))]
(cell (0 etc) (cell (cons (0 ls) (0 (1 etc))) (1 (1 etc))))))
(loop (-1 ls) n l&n)))))
(respg (loop (pg (0 lc)) n
(letrec [(respd (loop (pd (0 lc)) (0 respg)
(creer…ls&ns (-1 lc) (0 respd))))]
(1 respd))))]
(1 respg))))
(define (creer…lc&nsmax l old…nsmax)
(cond (null? l) (cell () old…nsmax)
(letrec [(dabordpg (traduire (pg (0 l)) (makebitarray *ns*)))
(dabordpd (traduire (pd (0 l)) (makebitarray *ns*)))
(nsmax (max (bitcount dabordpg) (bitcount dabordpd) old…nsmax))
(etc (creer…lc&nsmax (-1 l) nsmax))]
(cond (bitfind (bitand dabordpg dabordpd))
etc
(cell (consminimal (cell dabordpg dabordpd) (0 etc)) (1 etc))))))
(define (creer…tc/s&tc/nxx i tc/s tc/nsg tc/nsd)
(cond (=? i *nc*) (cell tc/s tc/nsg tc/nsd)
(letrec [(lhs (bcopy (pg (i *tc*))))
(rhs (bcopy (pd (i *tc*))))
(nlhs (bitcount lhs))
(nrhs (bitcount rhs))]
(bitset! (nlhs tc/nsg) i)
(bitset! (nrhs tc/nsd) i)
(cond (not (zero? nlhs))
(remplir…tc/s pg (bitfind lhs) lhs i tc/s)
(bitset! (pg (*ns* tc/s)) i))
(cond (not (zero? nrhs))
(remplir…tc/s pd (bitfind rhs) rhs i tc/s)
(bitset! (pd (*ns* tc/s)) i))
(creer…tc/s&tc/nxx (1+ i) tc/s tc/nsg tc/nsd))))
{••• Traduit une liste de symboles en un vecteur de bits en fonction du package dk}
(define (traduire l ba)
(cond (null? l) ba
(bitset! (traduire (-1 l) ba) (binding=? (intern 'dk (0 l)) ()))))
{••• Ajoute une clause dans une liste de clauses avec verification des soussommages: Tres long
*tc* se retrouve dans l'ordre inverse par rapport a la liste initiale}
(define (consminimal c lc)
(cond (null? lc) (list c)
(let [(interpg (bitand (pg (0 lc)) (pg c)))
(interpd (bitand (pd (0 lc)) (pd c)))]
(cond (and (=? interpg (pg (0 lc))) (=? interpd (pd (0 lc)))) lc
(and (=? interpg (pg c)) (=? interpd (pd c))) (consminimal c (-1 lc))
(cons (0 lc) (consminimal c (-1 lc)))))))
{••• … ou sans verification des soussommages
*tc* se retrouve dans l'ordre par rapport a la liste initiale}
(define consminimal cons)
{••• Allume le bit i dans les bitarrays de tc/s pour chaque symbole dans p}
(define (remplir…tc/s goud rang p i tc/s)
(cond rang (begin (bitset! (goud (rang tc/s)) i)
(bitclr! p rang)
(remplir…tc/s goud (bitfind p) p i tc/s))))
{••• Affecte ? aux *ns* symboles de *ts* dans le package dk}
(define (raz)
(cond (error? *ts*) †
(letrec [(ns (1- (blength *ts*)))
((loop n)
(cond (=? n ns) †
(begin (binding=! (intern 'dk (n *ts*)) () '?)
(loop (1+ n)))))]
(loop 0))))
{••• Extraordinaire barriere d'abstraction: pg partie gauche et pd partie droite}
(define pg 0)
(define pd 1)
{•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••}
(define (• lhs rhs)
(letrec
[(a (traduire lhs (makebitarray *ns*)))
(b (traduire rhs (makebitarray *ns*)))
(msk (bcopy *msk*))
(tc/nsg (bcopy *tc/nsg*))
(tc/nsd (bcopy *tc/nsd*))
(a->b (avancer…pg!ts a tc/nsg tc/nsd msk (avancer…pd!ts b tc/nsg tc/nsd msk (ccopy *a->b*))))
(rangtt (explorer tc/nsg tc/nsd msk))]
(cond (eq? a->b †) ()
(and (bitfind (0 tc/nsd)) rangtt)
(begin {(prin (ppc rangtt)) (pause)}
(prouver…ts 1 (bitmsk (pg (rangtt *tc*)) (pg a->b)) tc/nsg tc/nsd msk a->b))
())))
{•••prouve les clauses a->gb pour tout g de gamma}
(define (prouver…ts niveau gamma old…tc/nsg old…tc/nsd old…msk old…a->b)
(letrec [(rang (bitfind gamma))
(tc/nsg (bcopy old…tc/nsg))
(tc/nsd (bcopy old…tc/nsd))
(msk (bcopy old…msk))
(a->b (avancer…pd! rang tc/nsg tc/nsd msk (ccopy old…a->b)))
(tc/nsg…etc (bcopy old…tc/nsg))
(tc/nsd…etc (bcopy old…tc/nsd))
(msk…etc (bcopy old…msk))
(a->b…etc (avancer…pg! rang tc/nsg…etc tc/nsd…etc msk…etc (ccopy old…a->b)))
(rangtt (explorer tc/nsg tc/nsd msk))
(fils (prouver…ts (1+ niveau) (bitmsk (pg (rangtt *tc*)) (pg a->b)) tc/nsg tc/nsd msk a->b))]
{ (prin "***a***")
(prin (ppts (pg old…a->b)))
(prin "***b***")
(prin (ppts (pd old…a->b)))
(prin (ppts gamma))
(pause)}
(cond (not rang) ()
(eq? a->b †) (cond (eq? a->b…etc †) ()
(prouver…ts niveau (bitclr! gamma rang) tc/nsg…etc tc/nsd…etc msk…etc a->b…etc))
rangtt (cond (null? fils)
(cond (eq? a->b…etc †) ()
(prouver…ts niveau (bitclr! gamma rang)
tc/nsg…etc tc/nsd…etc msk…etc a->b…etc))
(eq? a->b…etc †) fils
(append fils (prouver…ts niveau (bitclr! gamma rang)
tc/nsg…etc tc/nsd…etc msk…etc a->b…etc)))
(eq? a->b…etc †) (list a->b)
(cons a->b (prouver…ts niveau (bitclr! gamma rang) tc/nsg…etc tc/nsd…etc msk…etc a->b…etc)))))
{•••reclasse les clauses dans tc/nsg et tc/nsd,
en avancant dans tc/nsg (tc/nsd) les clauses qui contiennent le symbole en pg (pd) d'un cran,
en mettant a jour le msk ie eteindre les bits des clauses qui contiennent le symbole en pd (pg)
en appelant avancer…pg!ts pour les symboles s dans les clauses ->s qui sont ainsi apparues
en appelant avancer…pd!ts pour les symboles s dans les clauses s-> qui sont ainsi apparues
Elle travaille physiquement sur chacun des tableaux et retourne a->b}
(define (avancer…pg!ts ts tc/nsg tc/nsd msk a->b)
(letrec [(new…ts (bitand! (bitnot (pg a->b)) ts))
(tc…0sg (0 tc/nsg))
(tc…1sg (1 tc/nsg))
((loop! rang ts tc/nsg)
(cond rang (begin (bitclr! ts rang) (bitand! (bitnot (pd (rang *tc/s*))) msk)
(loop! (bitfind ts) ts (avancer!tc (bitand msk (pg (rang *tc/s*))) tc/nsg 0)))
tc/nsg))
(new…tc/nsg (loop! (bitfind new…ts) new…ts tc/nsg))
(new…tc…->s (bitand! (1 tc/nsd) (bitmsk (0 new…tc/nsg) tc…0sg)))
(new…tsg (bitmsk (trouver…ts! pd (bitfind new…tc…->s) new…tc…->s) (pd a->b)))
(new…tc…s-> (bitand! (0 tc/nsd) (bitmsk (1 new…tc/nsg) tc…1sg)))
(new…tsd (bitmsk (trouver…ts! pg (bitfind new…tc…s->) new…tc…s->) (pg a->b)))]
(cond (eq? a->b †) †
(not (bitfind new…ts)) a->b
(bitfind (bitand ts (pd a->b))) †
(begin (bitor! new…ts (pg a->b))
(accede tc…0sg tc…1sg new…tsg new…tsd)
(cond (bitfind (bitand (0 new…tc/nsg) (0 tc/nsd))) †
(avancer…pg!ts new…tsg tc/nsg tc/nsd msk
(avancer…pd!ts new…tsd tc/nsg tc/nsd msk a->b)))))))
(define (avancer…pg! rang tc/nsg tc/nsd msk a->b)
(letrec [(tc…0sg (0 tc/nsg))
(tc…1sg (1 tc/nsg))
(new…tc/nsg (begin (bitand! (bitnot (pd (rang *tc/s*))) msk)
(avancer!tc (bitand msk (pg (rang *tc/s*))) tc/nsg 0)))
(new…tc…->s (bitand! (1 tc/nsd) (bitmsk (0 new…tc/nsg) tc…0sg)))
(new…tsg (bitmsk (trouver…ts! pd (bitfind new…tc…->s) new…tc…->s) (pd a->b)))
(new…tc…s-> (bitand! (0 tc/nsd) (bitmsk (1 new…tc/nsg) tc…1sg)))
(new…tsd (bitmsk (trouver…ts! pg (bitfind new…tc…s->) new…tc…s->) (pg a->b)))]
(cond (eq? a->b †) †
(rang (pd a->b)) †
(rang (pg a->b)) a->b
(begin (bitset! (pg a->b) rang)
(accede tc…0sg tc…1sg new…tsg new…tsd)
(cond (bitfind (bitand (0 new…tc/nsg) (0 tc/nsd))) †
(avancer…pg!ts new…tsg tc/nsg tc/nsd msk
(avancer…pd!ts new…tsd tc/nsg tc/nsd msk a->b)))))))
(define (avancer…pd!ts ts tc/nsg tc/nsd msk a->b)
(letrec [(new…ts (bitand! (bitnot (pd a->b)) ts))
(tc…0sd (0 tc/nsd))
(tc…1sd (1 tc/nsd))
((loop! rang ts tc/nsd)
(cond rang (begin (bitclr! ts rang) (bitand! (bitnot (pg (rang *tc/s*))) msk)
(loop! (bitfind ts) ts (avancer!tc (bitand msk (pd (rang *tc/s*))) tc/nsd 0)))
tc/nsd))
(new…tc/nsd (loop! (bitfind new…ts) new…ts tc/nsd))
(new…tc…->s (bitand! (0 tc/nsg) (bitmsk (1 new…tc/nsd) tc…1sd)))
(new…tsg (bitmsk (trouver…ts! pd (bitfind new…tc…->s) new…tc…->s) (pd a->b)))
(new…tc…s-> (bitand! (1 tc/nsg) (bitmsk (0 new…tc/nsd) tc…0sd)))
(new…tsd (bitmsk (trouver…ts! pg (bitfind new…tc…s->) new…tc…s->) (pg a->b)))]
(cond (eq? a->b †) †
(not (bitfind new…ts)) a->b
(bitfind (bitand ts (pg a->b))) †
(begin (bitor! ts (pd a->b))
(accede tc…0sd tc…1sd new…tsg new…tsd)
(cond (bitfind (bitand (0 tc/nsg) (0 new…tc/nsd))) †
(avancer…pg!ts new…tsg tc/nsg tc/nsd msk
(avancer…pd!ts new…tsd tc/nsg tc/nsd msk a->b)))))))
(define (avancer…pd! rang tc/nsg tc/nsd msk a->b)
(letrec [(tc…0sd (0 tc/nsd))
(tc…1sd (1 tc/nsd))
(new…tc/nsd (begin (bitand! (bitnot (pg (rang *tc/s*))) msk)
(avancer!tc (bitand msk (pd (rang *tc/s*))) tc/nsd 0)))
(new…tc…->s (bitand! (0 tc/nsg) (bitmsk (1 new…tc/nsd) tc…1sd)))
(new…tsg (bitmsk (trouver…ts! pd (bitfind new…tc…->s) new…tc…->s) (pd a->b)))
(new…tc…s-> (bitand! (1 tc/nsg) (bitmsk (0 new…tc/nsd) tc…0sd)))
(new…tsd (bitmsk (trouver…ts! pg (bitfind new…tc…s->) new…tc…s->) (pg a->b)))]
(cond (eq? a->b †) †
(rang (pg a->b)) †
(rang (pd a->b)) a->b
(begin (bitset! (pd a->b) rang)
(accede tc…0sd tc…1sd new…tsg new…tsd)
(cond (bitfind (bitand (0 tc/nsg) (0 new…tc/nsd))) †
(avancer…pg!ts new…tsg tc/nsg tc/nsd msk
(avancer…pd!ts new…tsd tc/nsg tc/nsd msk a->b)))))))
(define (avancer!tc tc tc/nxx n)
(cond (bitfind tc) (letrec [(ba (bitand tc ((1+ n) tc/nxx)))
(tc…nxx (bitor ba (n tc/nxx)))]
(accede tc…nxx)
(cell=! tc/nxx n tc…nxx)
(avancer!tc (bitmsk tc ba) tc/nxx (1+ n)))
tc/nxx))
{•••retourne le rang de la clause de tete entrainant le plus faible facteur de branchement ou ƒ}
(define (explorer tc/nsg tc/nsd msk)
(cond (bitfind (bitand msk (0 tc/nsd)))
(letrec [((loop n)
(cond (>? n *nsmax*) ƒ
(or (bitfind (bitand! (0 tc/nsd) (bitand msk (n tc/nsg)))) (loop (1+ n)))))]
(loop 2))))
{••• retourne le tas de symboles apparaissant dans la partie goud des clauses de tc}
(define (trouver…ts! goud rang tc)
(cond rang (begin (bitclr! tc rang)
(bitor! (goud (rang *tc*)) (trouver…ts! goud (bitfind tc) tc)))
(makebitarray *ns*)))
(define (clr!tc t goud a)
(let [(rang (bitfind a))]
(cond rang (begin (bitnot! (bitor! (goud (rang *tc/s*)) (bitnot! t)))
(bitclr! a rang)
(clr!tc t goud a))
t)))
(define (set!tc t goud a)
(let [(rang (bitfind a))]
(cond rang (begin (bitor! (goud (rang *tc/s*)) t)
(bitclr! a rang)
(set!tc t goud a))
(bitor! (goud (*ns* *tc/s*)) t))))
{•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••}
{••• projection de la partie goud d'une liste de feuilles d'échec sur une liste de symboles d'hypothèses}
(define (proj…lfe pgoud ls lfe)
(letrec [(ts (traduire ls (makebitarray *ns*)))
((loop l)
(cond (null? l) ()
(cons (bitand ts (pgoud (0 l))) (loop (-1 l)))))]
(loop lfe)))
{••• pseudo produit cartésien d'une liste de tas de symboles}
(define (pcart…lts lts)
(letrec [(ts (0 lts))
((loop1 pcart)
(cond (null? pcart) ()
(bitfind (bitand ts (0 pcart)))
(cons (0 pcart) (loop1 (-1 pcart)))
(pcart…2ts (bcopy ts) (0 pcart) (loop1 (-1 pcart)))))
((pcart…2ts ts1 ts2 tas)
(letrec [((loop rang ts1)
(cond rang (cons (bitset ts2 rang)
(begin (bitclr! ts1 rang) (loop (bitfind ts1) ts1)))
tas))]
(loop (bitfind ts1) ts1)))]
(cond (null? lts) ()
(null? (-1 lts)) (pcart…2ts (0 lts) (makebitarray *ns*) ())
(loop1 (pcart…lts (-1 lts))))))
(define rplacd cdr=!)
(setstrict rplacd %11)
{••• minimisation par inclusion d'une liste de tas de symboles}
(define (min!lts lts)
(cond (null? lts) ()
(letrec [((loop lp1)
(cond (null? (-1 lp1)) (loop…suite lts)
(not (bitfind (bitand! (0 lts) (bitnot (1 lp1)))))(loop (rplacd lp1 (-2 lp1)))
(not (bitfind (bitand! (1 lp1) (bitnot (0 lts)))))(min!lts (-1 lts))
(loop (-1 lp1))))
((loop…suite lp1)
(cond (null? (-1 lp1)) lts
(letrec [((loop…int lp2)
(cond (null? (-1 lp2)) (loop…suite (-1 lp1))
(not (bitfind (bitand! (1 lp1) (bitnot (1 lp2)))))
(loop…int (rplacd lp2 (-2 lp2)))
(not (bitfind (bitand! (1 lp2) (bitnot (1 lp1)))))
(loop…suite (rplacd lp1 (-2 lp1)))
(loop…int (-1 lp2))))]
(loop…int (-1 lp1)))))]
(loop lts))))
{••• retire de lts1 les environnements qui incluent des environnements de lts2}
(define (epurer lts1 lts2)
(letrec [((loop lts1)
(cond (null? lts1) ()
(letrec [(ts (0 lts1))
((loop…int lts2)
(cond (null? lts2) (cons ts (loop (-1 lts1)))
(bitfind (bitand! (0 lts2) (bitnot ts))) (loop…int (-1 lts2))
(loop (-1 lts1))))]
(loop…int lts2))))]
(loop lts1)))
{••• En résumé pourles nogoods:
(define l…nogoods (min!lts (pcart…lts (proj…lfe pd l…hypotheses (• ()())))))
et pour les labels:
(epurer (min!lts (pcart…lts (• a b))) l…nogoods)}
{•••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••••}
{••• un pretty print pour le rang d'une clause}
(define (ppc rang)
(cond rang (let [(c (rang *tc*))]
(cell (ppts (pg c)) (ppts (pd c))))
"Pas de regle"))
{••• un pretty print pour un vecteur de bits representant un ensemble de clauses}
(define (pptc p)
(letrec [(ba (bcopy p))
((loop rang)
(cond rang (cond (>? rang *nc*) ()
(begin (bitclr! ba rang) (cons (ppc rang) (loop (bitfind ba)))))
()))]
(loop (bitfind ba))))
{••• un pretty print pour le rang d'un symbole}
(define (pps rang)
(cond rang (rang *ts*)
"Pas de symbole"))
{••• un pretty print pour un vecteur de bits representant un ensemble de symboles}
(define (ppts p)
(letrec [(ba (bcopy p))
((loop rang)
(cond rang (begin (bitclr! ba rang) (cons (rang *ts*) (loop (bitfind ba))))
()))]
(loop (bitfind ba))))
{••• un pretty print pour une liste de vecteur de bits representant un ensemble de symboles}
(define (pplts lp)
(cond (null? lp) ()
(cons (ppts (0 lp)) (pplts (-1 lp)))))
{••• un pretty print pour les parties goud d'une liste de feuilles d'échec}
(define (pplfe pgoud lc)
(cond (null? lc) ()
(cons (ppts (pgoud (0 lc))) (pplfe pgoud (-1 lc)))))
(define (max n | l)
(cond (null? l) n
(<? n (0 l)) (apply max l)
(apply max (cons n (-1 l)))))
(defmacro (bitmsk x y)
`(bitand! ,x (bitnot! (bcopy ,y))))
(defmacro (bitand x y)
`(bitand! ,x (bcopy ,y)))
(defmacro (bitor x y)
`(bitor! ,x (bcopy ,y)))
(defmacro (bitnot x)
`(bitnot! (bcopy ,x)))
(defmacro (bitset x y)
`(bitset! (bcopy ,x) ,y))
(defmacro (ccopy a->b)
`(cell (bcopy (pg ,a->b)) (bcopy (pd ,a->b))))
{accede a la valeur d'une forme suspendue si la structure en est simple.
Attention: Pour un cell, elle n'accede pas a chaque element}
(defmacro (accede | l)
(cons 'begin (maplist 'null? l)))
{Imprime en sequence par prin les elements de l et retourne la valeur du premier arg}
(defmacro (prinloop val | l)
`(begin ,@(maplist 'prin l) (flushio stdo) ,val))
{le stepper s'arrete pour les ident de variables, les cons, les fermetures}
(define (step? expr env)
(or (=? (type expr) 6)
(=? (type expr) 12)
(=? (type expr) 13)
))
(let [(n 0)]
(define (stepin expr env)
(=! n (1+ n))(prin n)(prin ">>> ")
(print expr)
(print (envar env))
(pause) n))
(define (stepout n val)
(prin n)(prin "= ")
(printdebug val)
(pause))
(define (maplist f l)
(cond (null? l) ()
(cons (list f (0 l)) (maplist f (-1 l)))))
{Instancifie une clause pg -> pd
Appeler: (instance '(list ib:x) '(list ib:z) '(ib:x ib:z) '((1 2)(a b)) '(<? ib:x 10))
Retourne:
[(1) (a)]
[(1) (b)]
[(2) (a)]
[(2) (b)]}
(define (instance pg pd lvar ldom test)
(letrec [((loopvar lvar ldom)
(cond (null? lvar) (cond (eval test ()) (print (cell (eval pg ()) (eval pd ()))))
(loopval (0 lvar) (0 ldom) (-1 lvar) (-1 ldom))))
((loopval var dom lvar ldom)
(cond (cons? dom) (begin (binding=! var () (0 dom))
(loopvar lvar ldom)
(loopval var (-1 dom) lvar ldom))))]
(loopvar lvar ldom)))
)